home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 #1 / Ham Radio 2000.iso / ham2000 / packet / p_aa4re / bb212src / bbfin2.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-03-07  |  14.2 KB  |  420 lines
  1. (*===========================================================================*)
  2. (* Scan header line.  The R: has already been checked.                       *)
  3. (*                                                                           *)
  4. (*   Copyright 1988, 1989, 1990, 1991, 1992 by H. Roy Engehausen.  All       *)
  5. (*   rights reserved.                                                        *)
  6. (*                                                                           *)
  7. (*===========================================================================*)
  8.  
  9. FUNCTION scan_head(in_str : STRING;
  10.                    VAR calls_scanned : STRING;
  11.                    VAR dupe_cnt : WORD) : BOOLEAN;
  12.  
  13. {$UNDEF DEBUG}
  14. {$UNDEF DEBUG_CS}
  15.  
  16.   VAR
  17.  
  18.     at_pos            : BYTE;
  19.     no_pos            : BYTE;
  20.  
  21.     c                 : CHAR;
  22.     code              : INTEGER;
  23.     i                 : INTEGER;
  24.     j                 : INTEGER;
  25.     l                 : LONGINT;
  26.  
  27.     new_time          : LONGINT;
  28.     num_msg           : WORD;
  29.  
  30.     work_str          : STRING[12];
  31.     work_time         : DATETIME;
  32.  
  33.     o_user            : call_sign_str;
  34.  
  35.     t_bid             : bid_str;
  36.     t_flag            : msg_flag_type;
  37.  
  38.   BEGIN;
  39.  
  40.     (*-----------------------------------------------------------------------*)
  41.     (* Initialize and make sure we have the R:                               *)
  42.     (*-----------------------------------------------------------------------*)
  43.  
  44.     scan_head := FALSE;
  45.  
  46.     IF NOT substr_compare(in_str, 1, 'R:') THEN
  47.       EXIT;
  48.  
  49.     (*-----------------------------------------------------------------------*)
  50.     (* Initialize the reset                                                  *)
  51.     (*-----------------------------------------------------------------------*)
  52.  
  53.     num_msg   := 0;
  54.  
  55.     o_user := '';
  56.  
  57.     strip_crlf(in_str);
  58.     upcase_str_var(in_str);
  59.  
  60.     (*-----------------------------------------------------------------------*)
  61.     (* Handle some stupid errors                                             *)
  62.     (*-----------------------------------------------------------------------*)
  63.  
  64.     IF (in_str[4] = '0') OR (in_str[4] = '1') THEN
  65.       BEGIN;
  66.         IF substr_compare(in_str, 3, '000') OR
  67.            substr_compare(in_str, 3, '800') OR
  68.            substr_compare(in_str, 3, '810') THEN
  69.           in_str := 'R:880101/0001' + substr(in_str, 14, 0);
  70.       END;
  71.  
  72.     (*-----------------------------------------------------------------------*)
  73.     (* Convert the year.  If not valid, quit                                 *)
  74.     (*-----------------------------------------------------------------------*)
  75.  
  76.     VAL(SUBSTR(in_str, 3, 2), i, code);
  77.  
  78.     IF (code <> 0) OR (i < 88) THEN
  79.       EXIT;
  80.  
  81.     work_time.year := i + 1900;
  82.  
  83.     {$IFDEF DEBUG}
  84.       WRITELN('Year = ', work_time.year);
  85.     {$ENDIF}
  86.  
  87.     (*-----------------------------------------------------------------------*)
  88.     (* Convert the month.  If not valid, quit                                *)
  89.     (*-----------------------------------------------------------------------*)
  90.  
  91.     VAL(SUBSTR(in_str, 5, 2), i, code);
  92.     IF (code <> 0) OR (i < 1) OR (i > 12) THEN
  93.       EXIT;
  94.  
  95.     work_time.month := i;
  96.  
  97.     {$IFDEF DEBUG}
  98.       WRITELN('Month = ', work_time.month);
  99.     {$ENDIF}
  100.  
  101.     (*-----------------------------------------------------------------------*)
  102.     (* Convert the day.  If not valid, quit                                  *)
  103.     (*-----------------------------------------------------------------------*)
  104.  
  105.     VAL(SUBSTR(in_str, 7, 2), i, code);
  106.     IF (code <> 0) OR (i < 1) OR (i > 31) THEN
  107.       EXIT;
  108.  
  109.     work_time.day := i;
  110.  
  111.     {$IFDEF DEBUG}
  112.       WRITELN('Day = ', i);
  113.     {$ENDIF}
  114.  
  115.     (*-----------------------------------------------------------------------*)
  116.     (* Verify the date/time break                                            *)
  117.     (*-----------------------------------------------------------------------*)
  118.  
  119.     IF in_str[9] <> '/' THEN
  120.       EXIT;
  121.  
  122.     (*-----------------------------------------------------------------------*)
  123.     (* Convert the hour.  If not valid, quit                                 *)
  124.     (*-----------------------------------------------------------------------*)
  125.  
  126.     VAL(SUBSTR(in_str, 10, 2), i, code);
  127.     IF (code <> 0) OR (i < 0) OR (i > 24) THEN
  128.       EXIT;
  129.  
  130.     work_time.hour := i;
  131.  
  132.     {$IFDEF DEBUG}
  133.       WRITELN('Hour = ', i);
  134.     {$ENDIF}
  135.  
  136.     (*-----------------------------------------------------------------------*)
  137.     (* Convert the minutes.  If not valid, quit                              *)
  138.     (*-----------------------------------------------------------------------*)
  139.  
  140.     VAL(SUBSTR(in_str, 12, 2), i, code);
  141.     IF (code <> 0) OR (i < 0) OR (i > 59) THEN
  142.       EXIT;
  143.  
  144.     work_time.min := i;
  145.  
  146.     {$IFDEF DEBUG}
  147.       WRITELN('Min = ', i);
  148.     {$ENDIF}
  149.  
  150.     (*-----------------------------------------------------------------------*)
  151.     (* Set the seconds to zero and convert to internal format                *)
  152.     (*-----------------------------------------------------------------------*)
  153.  
  154.     work_time.sec := 0;
  155.  
  156.     convert_time(work_time, new_time);
  157.  
  158.     (*-----------------------------------------------------------------------*)
  159.     (* Find the "@" symbol.  Must have one                                   *)
  160.     (*-----------------------------------------------------------------------*)
  161.  
  162.     at_pos := POS('@', in_str);
  163.  
  164.     IF at_pos = 0 THEN EXIT;
  165.  
  166.     {$IFDEF DEBUG}
  167.       WRITELN('ATPOS = ', at_pos);
  168.     {$ENDIF}
  169.  
  170.     (*-----------------------------------------------------------------------*)
  171.     (* Process the incoming BID info                                         *)
  172.     (*-----------------------------------------------------------------------*)
  173.  
  174.     t_bid   := '';
  175.  
  176.     no_pos  := POS(' $:', in_str);
  177.  
  178.     IF (no_pos <> 0)
  179.           AND ((LENGTH(in_str) - 3) > no_pos)
  180.           AND ((active_tcb^.curr_msg.msg_i_mb.msg_flag AND mf_bid_change) = 0)
  181.           AND (no_pos > 1) THEN
  182.       BEGIN;
  183.  
  184.         work_str := COPY(in_str, no_pos + 3, 255);
  185.         work_str := subword(@work_str, 1, 1);
  186.  
  187.         IF LENGTH(work_str) < SIZEOF(t_bid) THEN
  188.           t_bid := work_str;
  189.  
  190.       END;
  191.  
  192.     (*-----------------------------------------------------------------------*)
  193.     (* Find the "#:" symbol.  If there is one, it's the NK6K format          *)
  194.     (* If not, it's the WA7MBL/KA2BQE format.  Convert the message number    *)
  195.     (*-----------------------------------------------------------------------*)
  196.  
  197.     no_pos  := POS('#:', in_str);
  198.  
  199.     IF no_pos <> 0 THEN
  200.       BEGIN;
  201.  
  202.         {$IFDEF DEBUG}
  203.           WRITELN('NOPOS = ', no_pos);
  204.         {$ENDIF}
  205.  
  206.         (*-------------------------------------------------------------------*)
  207.         (* Convert message number from NK6K Format                           *)
  208.         (*-------------------------------------------------------------------*)
  209.  
  210.         IF LENGTH(in_str) > no_pos THEN
  211.           INC(no_pos, 2);
  212.  
  213.         work_str := COPY(in_str, no_pos, 255);
  214.         work_str := subword(@work_str, 1, 1);
  215.         VAL(work_str, l, code);
  216.  
  217.       END
  218.     ELSE
  219.       BEGIN;
  220.  
  221.         (*-------------------------------------------------------------------*)
  222.         (* Convert message number from MBL Format                            *)
  223.         (*-------------------------------------------------------------------*)
  224.  
  225.         i := 15; (* Magic number pick by analysis of header *)
  226.  
  227.         WHILE (i <= LENGTH(in_str)) AND (in_str[i] = ' ') DO
  228.           INC(i);
  229.  
  230.         IF i >= LENGTH(in_str) THEN
  231.           EXIT;
  232.  
  233.         {$IFDEF DEBUG}
  234.           WRITELN('MBL ', i, ' ', at_pos, ' = ', in_str);
  235.         {$ENDIF}
  236.  
  237.         j := at_pos - i;
  238.  
  239.         (*-------------------------------------------------------------------*)
  240.         (* Number is too long.. Leave                                        *)
  241.         (*-------------------------------------------------------------------*)
  242.  
  243.         IF (j > 7) THEN
  244.           EXIT;
  245.  
  246.         (*-------------------------------------------------------------------*)
  247.         (* If a message number is present then convert it else randomize it  *)
  248.         (* This is for the darn THEBOX people who insist on no #             *)
  249.         (*-------------------------------------------------------------------*)
  250.  
  251.         IF j >= 1 THEN
  252.           BEGIN;
  253.             work_str := COPY(in_str, i, j);
  254.             VAL(work_str, l, code);
  255.           END
  256.         ELSE
  257.           BEGIN;
  258.             l    := RANDOM(32767) + 1;
  259.             code := 0;
  260.           END;
  261.  
  262.       END;
  263.  
  264.     {$IFDEF DEBUG}
  265.       WRITELN('NO = ', code, '/', l);
  266.     {$ENDIF}
  267.  
  268.     (*-----------------------------------------------------------------------*)
  269.     (* If we don't have a valid number then leave                            *)
  270.     (*-----------------------------------------------------------------------*)
  271.  
  272.     IF (code <> 0) OR (l < 1) OR (l > 9999999) THEN
  273.       EXIT;
  274.  
  275.     (*-----------------------------------------------------------------------*)
  276.     (* Make sure number is within range                                      *)
  277.     (*-----------------------------------------------------------------------*)
  278.  
  279.     num_msg := l AND $FFFF;
  280.  
  281.     (*-----------------------------------------------------------------------*)
  282.     (* Now we will locate the originating BBS and validate it.               *)
  283.     (*-----------------------------------------------------------------------*)
  284.  
  285.     IF in_str[at_pos + 1] = ':' THEN
  286.       at_pos := at_pos + 2
  287.     ELSE
  288.       INC(at_pos);
  289.  
  290.     in_str := COPY(in_str, at_pos, 255);
  291.     in_str := subword(@in_str, 1, 1);
  292.  
  293.     {$IFDEF DEBUG}
  294.       WRITELN('ATPOS = ', at_pos);
  295.       DELAY(1000);
  296.     {$ENDIF}
  297.  
  298.     (*-----------------------------------------------------------------------*)
  299.     (* Scan forward for a non-alphameric that ends the call                  *)
  300.     (*-----------------------------------------------------------------------*)
  301.  
  302.     i := 0;
  303.     REPEAT
  304.       INC(i);
  305.       IF i <= LENGTH(in_str) THEN
  306.         c := in_str[i]
  307.       ELSE
  308.         c := ' ';
  309.     UNTIL ((c <  'A') OR (c > 'Z'))
  310.                                  AND ((c <  '0') OR (c > '9'));
  311.  
  312.     IF i > 0 THEN
  313.       work_str := COPY(in_str, 1, i-1);
  314.  
  315.     {$IFDEF DEBUG_CS}
  316.       WRITELN('CALL  = ', i, ' = ', work_str);
  317.     {$ENDIF}
  318.  
  319.     IF (i > SIZEOF(bb_addr_str)) OR (i < 3) THEN
  320.       EXIT;
  321.  
  322.     (*-----------------------------------------------------------------------*)
  323.     (* Now see if the call has a hierarchical address attached....           *)
  324.     (* Note that an invalid hierarchcial address will not terminate the      *)
  325.     (* header scan                                                           *)
  326.     (*-----------------------------------------------------------------------*)
  327.  
  328.     IF c <> '.' THEN
  329.       in_str := ''
  330.     ELSE
  331.       BEGIN;
  332.  
  333.         INC(i);
  334.         in_str := COPY(in_str, i, 255);
  335.  
  336.         REPEAT
  337.           INC(i);
  338.           IF i <= LENGTH(in_str) THEN
  339.             c := in_str[i]
  340.           ELSE
  341.             c := ' ';
  342.         UNTIL ((c <  'A') OR (c > 'Z'))
  343.                                      AND ((c <  '0') OR (c > '9'))
  344.                                      AND (c <> '.')
  345.                                      AND (c <> '#');
  346.  
  347.         IF (i > 0) AND (i <= SIZEOF(h_addr_str)) THEN
  348.           in_str := COPY(in_str, 1, i-1)
  349.         ELSE
  350.           in_str := '';
  351.  
  352.       END;
  353.  
  354.     {$IFDEF DEBUG}
  355.       WRITELN('CALL  = ', i, ' = ', in_str);
  356.     {$ENDIF}
  357.  
  358.     (*-----------------------------------------------------------------------*)
  359.     (* If we got here, the the header parsed ok.  Set the message data       *)
  360.     (*-----------------------------------------------------------------------*)
  361.  
  362.     active_tcb^.curr_msg.msg_i_mb.msg_from_at := work_str;
  363.     active_tcb^.curr_msg.msg_i_mb.msg_from_h  := in_str;
  364.     active_tcb^.curr_msg.msg_i_mb.msg_dt_orig := new_time;
  365.     active_tcb^.curr_msg.msg_i_mb.msg_no_orig := num_msg;
  366.  
  367.     IF (t_bid <> '')
  368.              AND ((active_tcb^.curr_msg.msg_i_mb.msg_flag
  369.                               AND (mf_bid_change OR mf_bid_override)) = 0) THEN
  370.       BEGIN;
  371.         active_tcb^.curr_msg.msg_i_mb.msg_bid  := t_bid;
  372.         active_tcb^.curr_msg.msg_i_mb.msg_flag :=
  373.                      active_tcb^.curr_msg.msg_i_mb.msg_flag OR mf_bid_override;
  374.       END;
  375.  
  376.     (*-----------------------------------------------------------------------*)
  377.     (* Save this call so we can post the route list                          *)
  378.     (*-----------------------------------------------------------------------*)
  379.  
  380.     IF (LENGTH(calls_scanned) + LENGTH(work_str) + 1) <= 255 THEN
  381.       calls_scanned := calls_scanned + ' ' + work_str;
  382.  
  383.     {$IFDEF DEBUG_CS}
  384.       WRITELN('CScan=', LENGTH(calls_scanned), '=', calls_scanned);
  385.       WRITELN('CWork=', LENGTH(work_str), '=', work_str);
  386.     {$ENDIF}
  387.  
  388.     (*-----------------------------------------------------------------------*)
  389.     (* See if we should hold on a possible loop                              *)
  390.     (*-----------------------------------------------------------------------*)
  391.  
  392.     IF compare_call(active_tcb^.curr_msg.msg_i_mb.msg_from_at,
  393.                                                   opt_block.this_bb_addr) THEN
  394.       BEGIN;
  395.  
  396.         INC(dupe_cnt);
  397.         t_flag := active_tcb^.curr_msg.msg_i_mb.msg_flag;
  398.  
  399.         IF (dupe_cnt = opt_block.hold_dupe_hdr)
  400.                                            AND ((t_flag AND mf_hold) = 0) THEN
  401.           BEGIN;
  402.             active_tcb^.curr_msg.msg_i_mb.msg_flag := t_flag OR mf_hold;
  403.             active_tcb^.curr_msg.msg_i_mb.msg_reason := message_reason_loop;
  404.             send_message(message_reason_loop);
  405.           END;
  406.  
  407.       END;
  408.  
  409.     (*-----------------------------------------------------------------------*)
  410.     (* It worked!                                                            *)
  411.     (*-----------------------------------------------------------------------*)
  412.  
  413.     {$IFDEF DEBUG}
  414.       WRITELN('TRUE EXIT');
  415.     {$ENDIF}
  416.  
  417.     scan_head := TRUE;
  418.  
  419.   END; (*----- End scan head proc -------------------------------------------*)
  420.